(module woof-instructions mzscheme
  (require (only (lib "swindle.ss" "swindle")
                 push! pop! rest)) ;provides oo stuff
  (require (only (lib "misc.ss" "swindle")
                 list-set!)) ;misc helpers
  (require (lib "list.ss" "srfi" "1")) ;pre-prefixed with s:
  (require (lib "34.ss" "srfi")) ;provides exception handling
  (require (all-except (lib "43.ss" "srfi")
                       vector->list
                       vector-fill!))
  (require (lib "defmacro.ss"))
  (require (lib "kw.ss"))
  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 1)))
  (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
  (require (planet "read.ss" ("ryanc" "scripting.plt" 1))) ;provides read-all
  (require "woof-kernel.scm")
  (require "woof-machine-utils.scm")
  (require (only "woof-machine.scm"
                 execute-primitive)) ;misc helpers
  (require (lib "file.ss"))
  (require (lib "port.ss"))
  (require (lib "process.ss"))

  ;;;;;;;;;;;;;;;;;;;;;;
  ;; CPU instructions ;;
  ;;;;;;;;;;;;;;;;;;;;;;
  
  
  ;; Push primitive scheme constant to stack (not in use)
  (define do-CONST (lambda (instr state) (push-stack! (arg1 instr) state)))
  
  ;; Push value of constant to stack.
  (define do-GETC (lambda (instr state) (push-stack! (global-by-name (arg1 instr) (machine-state-globals state)) state)))
  
  ;; Push value of global to stack.
  (define do-GETG (lambda (instr state) (push-stack! (global-by-name (arg1 instr) (machine-state-globals state)) state)))
  
  ;; Push value of global to stack.
  (define do-SETG (lambda (instr state) (install-global! (top-of-stack state)
                                                         (arg1 instr)
                                                         (machine-state-globals state))))
  
  (define do-STRL (lambda (instr state) (push-stack! (woof-string-instance
                                                      (arg1 instr)
                                                      (machine-state-globals state))
                                                     state)))
  
  (define do-LSTL (lambda (instr state) (push-stack! (woof-list-instance
                                                      (let ((items ()))
                                                        (do ((i 0 (+ i 1)))
                                                            ((= i (arg1 instr)))
                                                          (set! items
                                                                (append items (list (pop-stack! state)))))
                                                        items) (machine-state-globals state))
                                                     state)))
  
  (define do-INTL (lambda (instr state) (push-stack! (woof-integer-instance
                                                      (arg1 instr) (machine-state-globals state))
                                                     state)))
  
  (define do-BLKL (lambda (instr state) (begin
                                          (push-stack! (new-woof-block-object
                                                        (machine-state-globals state)
                                                        #:code (machine-state-fn-code state)
                                                        #:code-pc (machine-state-pc state)
                                                        #:env (machine-state-env state))
                                                       state)
                                          (let ((pc (machine-state-pc state)))
                                            (set-machine-state-pc!
                                             state
                                             (- (+ pc (arg1 instr)) 1)))
                                          )))
  
  ;; install a function in global namespace
  (define do-CRFN (lambda (instr state) (begin
                                          (install-function! (new-woof-function-object
                                                              #:sig (woof-object-prim-data
                                                                     (pop-stack! state))
                                                              #:specs (woof-object-prim-data
                                                                       (pop-stack! state))
                                                              #:block (pop-stack! state))
                                                             (machine-state-globals state)
                                                             ))))
  
  (define do-POP (lambda (instr state) (pop-stack! state)))
  
  (define do-GVAR (lambda (instr state) (push-stack! (global-by-name ) state)))
  
  (define do-LVAR (lambda (instr state) (push-stack! (env-get-var
                                                      (machine-state-env state)
                                                      (arg1 instr)
                                                      (arg2 instr))
                                                     state)))
  
  (define do-LSET (lambda (instr state) (env-set-var!
                                         (machine-state-env state)
                                         (arg1 instr)
                                         (arg2 instr)
                                         (top-of-stack state))))
  
  (define do-JUMP (lambda (instr state) (set-machine-state-pc! state (arg1 instr))))
  
  (define do-FJUMP (lambda (instr state) (if (not (pop-stack! state))
                                             (set-machine-state-pc! state (arg1 instr)))))
  
  (define do-TJUMP (lambda (instr state) (if (pop-stack! state)
                                             (set-machine-state-pc! state (arg1 instr)))))
  
  ;; ARGS [number of arguments]
  (define do-ARGS (lambda (instr state) (begin
                                          (push! (make-vector (arg1 instr)) (machine-state-env state))
                                          (do ((i 0 (+ i 1)))
                                              ((= i (arg1 instr)))
                                            (env-set-var! (machine-state-env state) 0 i (pop-stack! state))))))
  
  ;; FUNC [signature] [number of arguments]
  (define do-FUNC (lambda (instr state) (push-stack! (let ((funcs
                                                            (applicable-functions
                                                             (arg1 instr)
                                                             (reverse (top-n-of-stack
                                                                       (arg2 instr) state))
                                                             (machine-state-globals state))
                                                            ))
                                                       (if (< 0 (length funcs))
                                                           (woof-function-object-block (first funcs))
                                                           (raise 'no-applicable-function)))
                                                     state)))
  
  ;; SAVE [pc offset on return]
  (define do-SAVE (lambda (instr state) (push-stack!
                                         (new-return-addr
                                          #:pc (- (+ (machine-state-pc state)
                                                     (arg1 instr)) 1)
                                          #:fn-code (machine-state-fn-code state)
                                          #:env (machine-state-env state))
                                         state
                                         )))
  
  ;; SAVECC [pc offset on return]
  (define do-SAVECC (lambda (instr state) (push-stack!
                                           (new-woof-continuation
                                            (machine-state-globals state)
                                            #:code-pc (- (+ (machine-state-pc state)
                                                            (arg1 instr)) 1)
                                            #:fn-code (machine-state-fn-code state)
                                            #:env (machine-state-env state)
                                            #:stack (machine-state-stack state))
                                           state
                                           )))
  
  ;; RETCC
  (define do-RETCC (lambda (instr state) (let ((val (pop-stack! state))
                                               (cc (pop-stack! state)))
                                           (set-machine-state-fn-code! state
                                                                       (woof-continuation-fn-code cc))
                                           (set-machine-state-env! state (woof-continuation-env cc))
                                           (set-machine-state-pc!
                                            state
                                            (woof-continuation-pc cc))
                                           (set-machine-state-stack! state
                                                                     (woof-continuation-stack cc))
                                           ;; remove the unused return address from the stack
                                           (pop-stack! state)
                                           ;; push the return val of continuation to stack
                                           (push-stack! val state)
                                           )))
  
  ;; CALLJ, install Block context, goto top of Block code
  (define do-CALLJ (lambda (instr state) (let ((b (pop-stack! state)))
                                           (pop-env! state)
                                           (set-machine-state-fn-code! state
                                                                       (woof-block-object-code b))
                                           (set-machine-state-env! state (woof-block-object-env b))
                                           (set-machine-state-pc!
                                            state
                                            (woof-block-object-code-pc b)))))
  
  ;; Like above, but provide args as a list object
  (define do-LSTCALLJ (lambda (instr state) (let ((b (pop-stack! state))
                                                  (arg-list (pop-stack! state)))
                                              (map (lambda (ea) (push-stack! ea state))
                                                   (woof-object-prim-data arg-list))
                                              (pop-env! state)
                                              (set-machine-state-fn-code! state (woof-block-object-code b))
                                              (set-machine-state-env! state (woof-block-object-env b))
                                              (set-machine-state-pc!
                                               state
                                               (woof-block-object-code-pc b)))))
  
  ;;Use return-addr at tos+1 to return from call
  (define do-RETURN (lambda (instr state)
                      (let ((ret (second (machine-state-stack state)))
                            (stack (machine-state-stack state))
                            )
                        (set-machine-state-fn-code! state (return-addr-fn-code ret))
                        (set-machine-state-env! state (return-addr-env ret))
                        (set-machine-state-pc! state (return-addr-pc ret))
			
                        ;; remove the return address from the stack
                        (set-machine-state-stack!
                         state (cons (first stack) (rest (rest stack))))
                        )))
  
  ;; CALL primitive function
  (define do-PRIM (lambda (instr state) (let ((prim-name (arg1 instr)))
					  (execute-primitive
					   prim-name
					   state
					   #f ))))
  
  ;; Binary primitives
  (define do-PRBIN (lambda (instr state)
                     (push-stack! (execute-binary-primitive (arg1 instr)
                                                            (pop-stack! state)
                                                            (pop-stack! state)
                                                            (machine-state-globals state)
                                                            )
                                  state)))
  
  ;; Unary primitives
  (define do-PRUNR (lambda (instr state)
                     (push-stack! (execute-unary-primitive (arg1 instr)
                                                           (pop-stack! state)
                                                           (machine-state-globals state)
                                                           )
                                  state)))
  
  (define do-HALT (lambda (instr state) (raise 'halt)))
  

 
   (provide (all-defined)) 
)